perm filename MIXSCR.F4[SCX,LCS]1 blob sn#308345 filedate 1978-02-19 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
C00009 ENDMK
CāŠ—;
C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
C***** ALL FILES MUST HAVE THE .SCR EXTENSION *****
C***** LOAD WITH RENAM.FAI 
C***** USE 'R LOADER'.  INCLUDE '/LLIB40.OLD[1,3]'.  OTHERWISE THERE
C	WILL BE READ ERRORS DUE TO BUGS IN CURRENT LIB40 3/77 *******

	COMMON /VV/Q(19),R(19),KL,N1,N2,N3,J,K,L,M,P1,PX,A,B,C,D,IBL
	COMMON /LNK/ NK,NZ(10),IP
	DATA IBL/'     '/
	TYPE 24
	NK=0
	LX=0
	ACCEPT 2,K,IP
	IF(K.EQ.'L')LX=-1
200	TYPE 20
	ACCEPT 2,N1
	IF(N1.EQ.IBL)GO TO 200
	IF(FINDIT(N1))CALL NOTFND(N1)
C  DO A LOOKUP FIRST OF ALL
CC	CALL RENAMX(N1,'SCR','$$$$1','DAT')
201	TYPE 22
	ACCEPT 2,N2
	IF(N2.EQ.IBL.OR.N2.EQ.N1)GO TO 201
	IF(FINDIT(N2))CALL NOTFND(N2)
	IF(LX.EQ.0)GO TO 202
1000	TYPE 41
	ACCEPT 2,K
	IF(K.EQ.IBL)GO TO 202
C TAKES UP TO 2+10 FILES.
	NK=NK+1
	NZ(NK)=K
	IF(NK.LT.10)GO TO 1000
	
202	TYPE 23
	ACCEPT 2,N3
	IF(N3.EQ.IBL)GO TO 202
	CALL OFILE(1,N3)
	TYPE 300
300	FORMAT(' ****** CAUTION ******'/
	1' ****** NEVER STOP THIS PROGRAM WHILE IT IS WORKING ******'/)
	CALL RENAMX(N1,'SCR','$$$$1','DAT')
	CALL RENAMX(N2,'SCR','$$$$2','DAT')
	CALL IFILE(21,'$$$$1')
	CALL IFILE(22,'$$$$2')
	TYPE 25
	IF(LX.EQ.0)GO TO 25
	CALL LINK
	GO TO 204
25	FORMAT(/' WORKING'/)
	DO 1 K=1,3
	READ(21,2)Q
	WRITE(1,2)Q
1	READ(22,2)Q
C READS FIRST 3 LINES
	
	CALL CHECK(N,Q,P1,21)
	CALL CHECK(M,R,PX,22)
CATCHES INSERTED LINES.
6	IF(PX.LT.P1)GO TO 5
	CALL RDWRT(N,P1,Q,21)
	IF(KL)10,6,6

5	CALL RDWRT(M,PX,R,22)
	IF(KL.EQ.0)GO TO 6

11	PX=10000
	GO TO 13
10	P1=10000
13	IF(P1.NE.10000.OR.M.NE.N)GO TO 6
CC13	IF(P1.NE.10000.AND.M.NE.N)GO TO 6
12	WRITE(1,7)
	REWIND 21
	REWIND 22
	CALL RENAMX('$$$$1','DAT',N1,'SCR')
	CALL RENAMX('$$$$2','DAT',N2,'SCR')
204	END FILE 1
	CALL RENAM(N3,'DAT',N3,'SCR')
	TYPE 203,N3
	CALL EXIT
203	FORMAT(/' ******  MIX FILE NAME = ',A5,'.SCR')
2	FORMAT(19A5)
7	FORMAT(' FINISH;')
24	FORMAT(' MIXES OR LINKS SCORE LISTS.'/
	1' USES ".SCR" EXTENSIONS ONLY!!! '/
	1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.'
	1//' L = LINK, <CR> = MIX  '$)
41	FORMAT(' TYPE NEXT FILE NAME OR <CR>  '$)
20	FORMAT(' TYPE FILE 1 (WITHOUT EXT.)   '$)
22	FORMAT(/' TYPE FILE 2  '$)
23	FORMAT(/' TYPE OUTPUT NAME  '$)
	END

	SUBROUTINE CHECK(N,Q,P1,J)
	COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,IBL
	DIMENSION Q(19),AA(50)
	KL=0
33	READ(J,30,END=100)L,N,K,Q,AA
	IF(Q(5).NE.' ')GO TO 32
	IF(Q(10).NE.'.')GO TO 32
	IF(Q(19).EQ.'.')GO TO 31
CATCHES INSERTED LINES.
32	REREAD 44,L,N,Q
	IF(N.EQ.'FINIS')KL=-1
	CALL SHORT(Q,N)
CC	TYPE 44,L,N,(Q(LL),LL=1,K)
	IF(KL)RETURN
CC	WRITE(1,44)L,N,(Q(LL),LL=1,K)
	GO TO 33
100	PAUSE 'CHECK'
31	REREAD 4,L,N,P1
	REREAD 44,L,N,Q
30	FORMAT(72A1)
4	FORMAT(A1,A5,F)
44	FORMAT(A1,20A5)
	END

	SUBROUTINE SHORT(Q,N)
	COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,A,B,IBL
	COMMON /LNK/ NK,NZ(10),IP
	DIMENSION Q(1)
	K=19
	DO 1 K=19,1,-1
1	IF(Q(K).NE.' ')GO TO 2
2	IF(IP.NE.IBL)TYPE 44,L,N,(Q(LL),LL=1,K)
	IF(KL)RETURN
	WRITE(1,44)L,N,(Q(LL),LL=1,K)
44	FORMAT(A1,20A5)
	END

	SUBROUTINE RDWRT(I,P,R,J)
	COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
	DIMENSION R(19)
	KL=0
	CALL SHORT(R,I)
CC	WRITE(1,44)L,I,(R(N),N=1,K)
CC	TYPE 44,L,I,(R(N),N=1,K)
1	READ (J,44,END=100)L,I,R
	REREAD 44,L,I,R
	CALL SHORT(R,I)
CC	WRITE(1,44)L,I,(R(N),N=1,K)
CC	TYPE 44,L,I,(R(N),N=1,K)
	IF(I.NE.'PRINT')GO TO 1 
2	CALL CHECK(I,R,P,J)
	RETURN
44	FORMAT(A1,20A5)
100	PAUSE 'RDWRT'
	END

	SUBROUTINE LINK
	COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
	COMMON /LNK/ NK,NZ(10),IP
44	FORMAT(A1,20A5)
	KL=0
	JJ=0
	J=21
1	READ(J,44)L,LL,Q
	IF(LL.EQ.'FINIS')GO TO 2
4	CALL SHORT(Q,LL)
	IF(JJ.GT.NK)RETURN
	GO TO 1
2	IF(J.NE.21)GO TO 3
	REWIND 21
	CALL RENAMX('$$$$1','DAT',N1,'SCR')
	J=J+1
	GO TO 1
3	REWIND 22
	IF(JJ.NE.0)GO TO 6
	CALL RENAMX('$$$$2','DAT',N2,'SCR')
	GO TO 5
6	CALL RENAMX('$$$$2','DAT',NZ(JJ),'SCR')
5	JJ=JJ+1
	IF(JJ.GT.NK)GO TO 4
	CALL RENAMX(NZ(JJ),'SCR','$$$$2','DAT')
	CALL IFILE(22,'$$$$2')
	GO TO 1
	END

	SUBROUTINE RENAMX(J,K,L,M)
	CALL RENAM(J,K,L,M)
	TYPE 1,J,K,L,M
1	FORMAT(' (RENAME -- ',A5,'.',A3,' CHANGED TO -- ',A5,'.',A3,')')
	END
 
	SUBROUTINE NOTFND(NM)
	TYPE 1,NM
	CALL EXIT
1	FORMAT(' ******* FILE ',A5,'.SCR   NOT FOUND *****')
	END